home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / toplevel.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  5.5 KB  |  226 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.  
  24.     toplevel.c
  25.  
  26.     Top-Level Forms and Declarations
  27. */
  28.  
  29. #include "include.h"
  30.  
  31. object Scompile, Sload, Seval;
  32. object Sprogn;
  33.  
  34.  
  35. object Swarn;
  36.  
  37. object siVinhibit_macro_special;
  38.  
  39. object Stypep;
  40.  
  41. Fdefun(args)
  42. object args;
  43. {
  44.     object name;
  45.     object body, form;
  46.  
  47.     if (endp(args) || endp(MMcdr(args)))
  48.         FEtoo_few_argumentsF(args);
  49.     if (MMcadr(args) != Cnil && type_of(MMcadr(args)) != t_cons)
  50.         FEerror("~S is an illegal lambda-list.", 1, MMcadr(args));
  51.     name = MMcar(args);
  52.     if (type_of(name) != t_symbol)
  53.         not_a_symbol(name);
  54.     if (name->s.s_sfdef != NOT_SPECIAL) {
  55.         if (name->s.s_mflag) {
  56.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  57.                 name->s.s_sfdef = NOT_SPECIAL;
  58.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  59.          FEerror("~S, a special form, cannot be redefined.", 1, name);
  60.     }
  61.     if (name->s.s_hpack == lisp_package &&
  62.         name->s.s_gfdef != OBJNULL && initflag) {
  63.         vs_push(make_simple_string(
  64.             "~S is being redefined."));
  65.         ifuncall2(Swarn, vs_head, name);
  66.         vs_pop;
  67.     }
  68.     vs_base = vs_top;
  69.     if (lex_env[0] == Cnil && lex_env[1] == Cnil && lex_env[2] == Cnil) {
  70.         vs_push(MMcons(Slambda_block, args));
  71.     } else {
  72.         vs_push(MMcons(lex_env[2], args));
  73.         vs_base[0] = MMcons(lex_env[1], vs_base[0]);
  74.         vs_base[0] = MMcons(lex_env[0], vs_base[0]);
  75.         vs_base[0] = MMcons(Slambda_block_closure, vs_base[0]);
  76.     }
  77.     {object fname =  clear_compiler_properties(name,vs_base[0]);
  78.      fname->s.s_gfdef = vs_base[0];
  79.      fname->s.s_mflag = FALSE;}
  80.     vs_base[0] = name;
  81.     for (body = MMcddr(args);  !endp(body);  body = body->c.c_cdr) {
  82.         form = macro_expand(body->c.c_car);
  83.         if (type_of(form) == t_string) {
  84.             if (endp(body->c.c_cdr))
  85.                 break;
  86.             vs_push(form);
  87.             name->s.s_plist =
  88.             putf(name->s.s_plist,
  89.                  form,
  90.                  siSfunction_documentation);
  91.             vs_pop;
  92.             break;
  93.         }
  94.         if (type_of(form) != t_cons || form->c.c_car != Sdeclare)
  95.             break;
  96.     }
  97. }
  98.     
  99. siLAmake_special()
  100. {
  101.     check_arg(1);
  102.     check_type_symbol(&vs_base[0]);
  103.     if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
  104.         FEerror("~S is a constant.", 1, vs_base[0]);
  105.     vs_base[0]->s.s_stype = (short)stp_special;
  106. }
  107.  
  108. siLAmake_constant()
  109. {
  110.     check_arg(2);
  111.     check_type_symbol(&vs_base[0]);
  112.     if ((enum stype)vs_base[0]->s.s_stype == stp_special)
  113.         FEerror(
  114.          "The argument ~S to DEFCONSTANT is a special variable.",
  115.          1, vs_base[0]);
  116.     vs_base[0]->s.s_stype = (short)stp_constant;
  117.     vs_base[0]->s.s_dbind = vs_base[1];
  118.     vs_pop;
  119. }
  120.  
  121. Feval_when(arg)
  122. object arg;
  123. {
  124.     object *base = vs_base;
  125.     object ss;
  126.     bool flag = FALSE;
  127.  
  128.     if(endp(arg))
  129.         FEtoo_few_argumentsF(arg);
  130.     for (ss = MMcar(arg);  !endp(ss);  ss = MMcdr(ss))
  131.         if(MMcar(ss) == Seval)
  132.             flag = TRUE;
  133.         else if(MMcar(ss) != Sload && MMcar(ss) != Scompile)
  134.          FEinvalid_form("~S is an undefined situation for EVAL-WHEN.",
  135.                 MMcar(ss));
  136.     if(flag) {
  137.         vs_push(make_cons(Sprogn, MMcdr(arg)));
  138.         eval(vs_head);
  139.     } else {
  140.         vs_base = base;
  141.         vs_top = base+1;
  142.         vs_base[0] = Cnil;
  143.     }
  144. }
  145.  
  146. Fdeclare(arg)
  147. object arg;
  148. {
  149.     FEerror("DECLARE appeared in an invalid position.", 0);
  150. }
  151.  
  152. Flocally(body)
  153. object body;
  154. {
  155.     object *oldlex = lex_env;
  156.     object x, ds, vs, v;
  157.  
  158.     lex_copy();
  159.     body = find_special(body, NULL, NULL);
  160.     vs_push(body);
  161.     Fprogn(body);
  162.     lex_env = oldlex;
  163. }
  164.  
  165. Fthe(args)
  166. object args;
  167. {
  168.     object *vs;
  169.  
  170.     if(endp(args) || endp(MMcdr(args)))
  171.         FEtoo_few_argumentsF(args);
  172.     if(!endp(MMcddr(args)))
  173.         FEtoo_many_argumentsF(args);
  174.     eval(MMcadr(args));
  175.     args = MMcar(args);
  176.     if (type_of(args) == t_cons && MMcar(args) == Svalues) {
  177.         vs = vs_base;
  178.         for (args=MMcdr(args); !endp(args); args=MMcdr(args), vs++){
  179.             if (vs >= vs_top)
  180.                 FEerror("Too many return values.", 0);
  181.             if (ifuncall2(Stypep, *vs, MMcar(args)) == Cnil)
  182.                 FEwrong_type_argument(MMcar(args), *vs);
  183.         }
  184.         if (vs < vs_top)
  185.             FEerror("Too few return values.", 0);
  186.     } else {
  187.         if (ifuncall2(Stypep, vs_base[0], args) == Cnil)
  188.             FEwrong_type_argument(args, vs_base[0]);
  189.     }
  190. }
  191.  
  192. init_toplevel()
  193. {
  194.     make_special_form("DEFUN",Fdefun);
  195.     make_si_function("*MAKE-SPECIAL", siLAmake_special);
  196.     make_si_function("*MAKE-CONSTANT", siLAmake_constant);
  197.     make_special_form("EVAL-WHEN", Feval_when);
  198.     make_special_form("THE", Fthe);
  199.     Scompile = make_ordinary("COMPILE");
  200.     enter_mark_origin(&Scompile);
  201.     Sload = make_ordinary("LOAD");
  202.     enter_mark_origin(&Sload);
  203.     Seval = make_ordinary("EVAL");
  204.     enter_mark_origin(&Seval);
  205.     make_special_form("DECLARE",Fdeclare);
  206.     Sdeclare = make_ordinary("DECLARE");
  207.     enter_mark_origin(&Sdeclare);
  208.     Sprogn = make_ordinary("PROGN");
  209.     enter_mark_origin(&Sprogn);
  210.     Seval = make_ordinary("EVAL");
  211.     enter_mark_origin(&Seval);
  212.     make_special_form("LOCALLY",Flocally);
  213.  
  214.     siSvariable_documentation
  215.     = make_si_ordinary("VARIABLE-DOCUMENTATION");
  216.     siSfunction_documentation
  217.     = make_si_ordinary("FUNCTION-DOCUMENTATION");
  218.  
  219.     Swarn = make_ordinary("WARN");
  220.     enter_mark_origin(&Swarn);
  221.  
  222.     Svalues = make_ordinary("VALUES");
  223.     Stypep = make_ordinary("TYPEP");
  224.     enter_mark_origin(&Stypep);
  225. }
  226.